perm filename MORSER.F4[HAK,HPM] blob sn#066981 filedate 1974-06-17 generic text, type T, neo UTF8
00100	      DIMENSION IPER(10),INTR(10),LPHA(51),MORS(51)
00200	      DATA IDOT/1/,IDASH/5/,IPOS/-1/,ISPAC/-5/,KMAX/10/,LNUM/51/
00300	      DATA LAFG/1/,SPAV/-2.5/,DAV/2.5/
00400	      DATA LPHA/'E','T','I','A','N','M','S','U','R','W','D'
00500	     1,'K','G','O','H','V','F','L','P','J','B','X','C','Y','Z','Q'
00600	     2,'5','4','3','2','1','6','7','8','9','0','%','?','+','"'
00650	     3,'.','''','-',';','(',',',':','ε','\','@','$'/
00700	      DATA MORS/1,2,4,5,7,8,13,14,16,17,22,23,25,26,40,41,43,49
00800	     1,52,53,67,68,70,71,76,77,121,122,125,134,161,202,229
00900	     2,238,241,242,374,400,401,448,455,484,608,637,644,692,715
00950	     3,1823,3280,5747,10192/
01000	    8 DO 4 I=1,10
01100	      IPER(I)=0
01200	    4 INTR(I)=0
01300	      DO 1 I = 1,10
01400	    3 CALL NEXT(100,IPER(I),IFY)
01500	      GO TO (2,3),IFY
01600	    2 CALL NEXT(4*ISPAC,INTR(I),IFY)
01700	      II=I
01800	      GO TO (5,6),IFY
01900	    5 IF(FLOAT(INTR(I)).LE.SPAV) GO TO 7
02000	    1 CONTINUE
02100	      CALL MAXM(10,INTR,ISPAC,IPOS)
02150		SPAV=(-1.-SQRT(FLOAT(1+ISPAC*IPOS)))*.1+.9*SPAV
02200	      GO TO 8
02300	    6 LAFG=2
02400	      II=I-1
02500	    7 IF(II.LE.1) GO TO 12
02600	      CALL MAXM(II,INTR,MAX,IPOS)
02700	      IF(LAFG.EQ.1) ISPAC=MAX
02800	   12 IF(I.NE.1) GO TO 10
02900	      KS=KS+1
03000	      IF(KS.LT.5) GO TO 9
03100	      ISPAC=2*ISPAC
03200	   10 KS=1
03250	    9 SPAV=(-1.-SQRT(FLOAT(ISPAC*IPOS)))*.1+.9*SPAV
03300	      CALL MAXM(I,IPER,MIN,MAX)
03400	      IF(MAX.LT.2*MIN) GO TO 13
03500	      IDOT=MIN
03600	      IDASH = MAX
03650		DAV=(1.+SQRT(FLOAT(IDOT*IDASH)))*.1+.9*DAV
03700	   13 ICHR=0
03800	      DO 14 J=1,I
03900	      K=1
04000	      IF(FLOAT(IPER(J)).GT.DAV) K=2
04100	   14 ICHR=ICHR*3+K
04200	      I=1
04300	      J=LNUM
04400	   16 IF(I.GT.J) GO TO 15
04500	      K=(I+J)/2
04600	      IF(MORS(K)-ICHR) 19,18,17
04700	   17 J=K-1
04800	      GO TO 16
04900	   19 I=K+1
05000	      GO TO 16
05100	   18 CALL CHAR(LPHA(K))
05300	      GO TO (8,22),LAFG
05400	   22 LAFG=1
05500	      CALL CHAR(' ')
05700	      GO TO 8
05800	   15 CALL CHAR('-')
06000	      GO TO 8
06100	      END
06200	
06300	      SUBROUTINE MAXM(N,IR,MIN,MAX)
06400	      DIMENSION IR(N)
06500	      MAX=IR(1)
06600	      MIN=MAX
06700	      DO 1 I=1,N
06800	      IF(IR(I).LT.MIN) MIN=IR(I)
06900	      IF(IR(I).GT.MAX) MAX=IR(I)
07000	    1 CONTINUE
07100	      RETURN
07200	      END
07300	
07400	      SUBROUTINE NEXT(MAX,LEN,IFY)
07401		COMMON/HREE/IGG
07500	      DIMENSION IN(200)
07600	      DATA IG/1/,I/1/,LEG/200/
07700	      IFY=1
07800	      GO TO (1,2),IG
07975	    1 CALL MORSIN(IN,LEG)
08000	      IG=2
08150	    2 IF(IGG.NE.0.AND.IGG.NE.I) GO TO 4
08200	      IF(IABS(IN(I)).GT.IABS(MAX)) GO TO 3
08300	      CALL SLEEP(0)
08400	      GO TO 2
08500	    4 LEN=IN(I)
08800	      I=MOD(I,LEG)+1
08900	      IF(LEN*MAX.LT.0) GO TO 2
09000	      RETURN
09100	    3 LEN=IN(I)
09200	      IFY=2
09300	      CALL SLEEP(0)
09400	      RETURN
09500	      END